home *** CD-ROM | disk | FTP | other *** search
/ Cream of the Crop 1 / Cream of the Crop 1.iso / CAD / LAUNCH36.ARJ / CMENU.LSP < prev    next >
Lisp/Scheme  |  1991-04-17  |  9KB  |  319 lines
  1. ; Custom#Menu copyright 1990 Mountain Software - all rights reserved
  2. ; 4/17/91 version 1.7
  3. ;------
  4.  
  5. (princ "\nLoading CMenu...")
  6.  
  7. ;------
  8. Initialize global variables
  9. ;------
  10.  
  11. (setq _typ      "Command"
  12.       _lstyp    _typ
  13.       _lblk    nil
  14. )
  15.  
  16. ;------
  17. ; our error routine
  18. ;------
  19.  
  20. (defun cm:err (s)
  21.   (if f (setq f (close f)))
  22.   (grtext)  (redraw)
  23.   (princ (strcat "\nCMenu Error: " s))
  24.   (setq *error* olderr)
  25.   (princ)
  26. )
  27.  
  28. ;------
  29. ; Block insert routine
  30. ;------
  31.  
  32. (defun doinsert (/ _blk blkrec lstrec s xscale yscale rot)
  33.     (if (null _lblk) (progn
  34.     (setq blkrec (tblnext "BLOCK" T)          ;retrieve first block
  35.           lstrec blkrec)
  36.     (while (boundp 'blkrec)
  37.       (setq blkrec (tblnext "BLOCK"))
  38.       (if (boundp 'blkrec) (setq lstrec blkrec))
  39.     )
  40.     (if (boundp 'lstrec) (setq _lblk (cdr (assoc 2 lstrec))))
  41.     ))
  42.     (if (null _lblk) (progn
  43.       (initget 1)
  44.       (setq s "\nBlock name: ")
  45.     )
  46.       (setq s (strcat "\nBlock name[" _lblk "]:"))
  47.     )
  48.     (setq _blk (getstring s))
  49.     (if (= _blk "") (setq _blk _lblk))
  50.     (setq xscale (strcat(getstring "X scale factor \"\\\" to prompt <1>:")))
  51.     (if (= xscale "") (setq xscale "1;")
  52.       (if(/= xscale "\\") (setq xscale (strcat xscale ";"))))
  53.     (setq yscale (getstring "Y scale factor \"\\\" to prompt (default=X):"))
  54.     (if (= yscale "") (setq yscale ";")
  55.       (if(/= yscale "\\") (setq yscale (strcat yscale ";"))))
  56.     (setq rot     (getstring "Rotation Angle \"\\\" to prompt <0>:"))
  57.     (if (= rot "") (setq rot "0;") ;else
  58.       (if(/= rot "\\") (setq rot (strcat rot ";"))))
  59.     (if (boundp '_blk)
  60.       (setq _cmd (strcat _blk ";\\" xscale yscale rot))
  61.       (setq _cmd nil))
  62. )
  63.  
  64. ;------
  65. ; Command input function
  66. ;------
  67.  
  68. (defun docommand ()
  69.     (princ(strcat
  70.       "\nSpecial Menu Command Characters:"
  71.       "\n^C^C = Cancel, ^P = Toggle menuecho, ; = Return, \\ = Pause for input"))
  72.     (setq _cmd (getstring t "\nEnter menu command: "))
  73. )
  74.  
  75. ;------
  76. ; AutoLisp function
  77. ;------
  78.  
  79. (defun dolisp (/ al_fn al_cmd)
  80.     (setq al_fn  (getstring "\nAutolisp filename: ")
  81.       al_cmd (getstring(strcat "\nAutolisp command to execute "
  82.                    "\".\" for none[" al_fn "]: ")))
  83.     (if (= al_cmd "") (setq al_cmd al_fn))
  84.     (if (= al_fn "")
  85.       (setq _cmd al_cmd) ;else
  86.       (if (= al_cmd ".")
  87.     (setq _cmd (strcat "^C^C^P(load\"" al_fn "\") ^P"))
  88.     (setq _cmd (strcat "^C^C^P(cond ((null "
  89.              (if(= (chr 40) (substr al_cmd 1 1))
  90.                (substr al_cmd 2 (-(strlen al_cmd)2))
  91.                (strcat "c:" al_cmd)
  92.              )
  93.              ") (load \""
  94.              al_fn "\")) (t (princ))) "
  95.              al_cmd " ^P"))
  96.       )
  97.     )
  98. )
  99.  
  100. ;------
  101. ; Write Parameter file
  102. ;------
  103.  
  104. (defun writedat (/ f mfn)
  105.     (setq f (open "cmenu.dat" "w"))
  106.     (if (boundp 'f) (progn
  107.     (if (null(setq mfn (findfile(strcat(getvar "MENUNAME")".MNU"))))
  108.     (progn
  109.       (princ "\nUnable to locate menu file on the AutoCAD library path")
  110.       (princ(strcat(getvar "MENUNAME") "\n") f)
  111.     ) ;else
  112.       (princ (strcat mfn "\n") f)
  113.     )
  114.     (princ (strcat
  115.       (getvar "DWGPREFIX") "\n"     (getvar "ACADPREFIX") "\n"
  116.       _ttl "\n"                     (itoa mode) "\n"
  117.       (itoa item) "\n"              insovr "\n"
  118.       _typ "\n"                     _cmd "\n") f)
  119.     (close f)
  120.   ) (princ "\nError opening CMENU.DAT"))
  121. )
  122.  
  123. ;------
  124. ; append a command to command string
  125. ;------
  126.  
  127. (defun add_cmd(subcmd)
  128.    (setq _cmd  (strcat _cmd subcmd))
  129. )
  130.  
  131. (defun clr_menu(start cnt)
  132.   (repeat cnt (grtext (setq start (1+ start)) " "))
  133. )
  134.  
  135. ;------
  136. ; Learn routine - original author unknown
  137. ;------
  138.  
  139. (defun learn ( / last n point string getinput inkey sl)
  140.   (graphscr)
  141.   (mapcar 'grtext
  142.     '(-1 -2 4 5 6 7 8)
  143.     '("***<< Learn Mode Active >>***" "[ Menus are disabled ]"
  144.       "******" "Learn" "Mode" "Active" "******")
  145.   )
  146.   (clr_menu -1 4)
  147.   (clr_menu 8 17)
  148.   (terpri) (prompt(strcat
  149.     "Enter commands from keyboard or pick point from digitizer, <ESC> to end:"
  150.     "\nLEARN: "))
  151.   (setq getinput T
  152.     string     ""
  153.     point     nil)
  154.   (setvar "CMDECHO" 1)
  155.   (while (= getinput t)
  156.     (setq inkey (grread))
  157.     (cond
  158.       ;*---- key press
  159.       ((= (car inkey) 2)
  160.     (kbprocess))
  161.       ;*---- point pick
  162.       ((and (= (car inkey) 3) (= string ""))
  163.     (progn
  164.       (setq point (cadr inkey))
  165.       (command point)
  166.       (add_cmd "\\")
  167.       (prompt "\nLEARN: ")
  168.     )
  169.       )
  170.       ;*---- user selected a menu item
  171.       (T   (prompt(strcat
  172.        "\nError: Keyboard commands and point picks only, please.\nLEARN: "
  173.        string))
  174.       )
  175.     );cond
  176.   );while
  177.   (setq sl (strlen _cmd))
  178.   (if(> sl 0) (progn
  179.     (setq last (substr _cmd sl 1))
  180.     (if(or(= last "\\")(= last ";"))
  181.       (setq _cmd (strcat "^C^C^P" _cmd "^P"))
  182.       (setq _cmd (strcat "^C^C^P" _cmd " ^P"))
  183.     )
  184.   ))
  185.   (setvar "CMDECHO" 0)
  186. )
  187.  
  188. ;------
  189. ; process the keyboard data from grread
  190. ;------
  191.  
  192. (defun kbprocess ( / char prmpt)
  193.   (setq char (cadr inkey))        ; get keyboard character
  194.   (cond
  195.     ;*--- backspace
  196.     ((= char 8)
  197.       (if(>(strlen string) 0) (progn
  198.     (setq string (substr string 1 (1- (strlen string))))
  199.     (prompt(strcat "\nCommand: " string))
  200.       ))
  201.     )
  202.     ;*--- escape
  203.     ((= char 27)
  204.       (setq getinput nil))
  205.     ;*--- Enter or space
  206.     ((or(= char 13)(= char 32))
  207.       (if (= (strcase string) "PAUSE") (progn
  208.         (setq  prmpt  (getstring T "\nEnter text for menu prompt: ")
  209.            string (getstring "\nEnter current response to ACAD prompt: ")
  210.     )
  211.     (command string)
  212.     (if(>(strlen prmpt) 0)
  213.       (setq string (strcat "(terpri)(prompt \""  prmpt  "\")(princ) \\" ))
  214.     ;else
  215.       (setq string "\\")
  216.     )
  217.       );else
  218.       (progn
  219.     (if (=(substr string 1 1) (chr 40)) (progn ;AutoLISP function entered
  220.       (eval(read string))
  221.       (setvar "CMDECHO" 1)
  222.       (prompt "\nResuming learn after AutoLISP call...")
  223.     ) ;else
  224.     (progn
  225.       (terpri)
  226.       (command string)
  227.     ))
  228.     (setq string(strcat string (if(= char 13) ";" " ")))
  229.       ))
  230.       (add_cmd string)
  231.       (setq string "")
  232.       (prompt "\nLEARN: ")
  233.     )
  234.     ;*--- default, add key to string
  235.     (T
  236.       (setq string (strcat string (chr char)))
  237.       (prompt (chr char))
  238.     )
  239.   )
  240. )
  241.  
  242. ;------
  243. ; Main
  244. ;------
  245.  
  246. (defun C:CMENU (/ cecho trk done bakfile olderr)
  247.   (princ "\nCMenu initializing...")
  248.   (setq cecho (getvar "CMDECHO")
  249.     _ttl  ""
  250.     _cmd  ""
  251.         olderr *error*
  252.     *error* cm:err
  253.   )
  254.   (setvar "CMDECHO" 0)
  255.   (command "MENU" "")
  256.   (graphscr)
  257.   (princ "\n\n\nPick Tablet, Button or Screen Menu Location with cursor...")
  258.   (setq trk    (grread)
  259.     mode    (car trk)
  260.     item    (cadr trk)
  261.     done    nil
  262.   )
  263.   (cond ((= mode 4)
  264.         (if (< item 1000)    (princ "\nScreen Menu selected ") ;else
  265.                 (princ "\nPopUp Menu selected "))
  266.     )
  267.     ((= mode 6) (princ "\nButtons selected "))
  268.     ((= mode 7) (princ "\nTABLET1 selected "))
  269.     ((= mode 8) (princ "\nTABLET2 selected "))
  270.     ((= mode 9) (princ "\nTABLET3 selected "))
  271.     ((= mode 10) (princ "\nTABLET4 selected "))
  272.     ((= mode 11) (princ "\nAUX1 selected "))
  273.     ((= mode 13) (princ "\nKeyboard Menu selected "))
  274.     (t  (setq done t))
  275.   )
  276.   (if (not done) (progn
  277.     (if (and (>= mode 6) (<= mode 11))
  278.       (setq insovr "Overwrite") ;else
  279.     (progn
  280.       (initget 0 "Add Insert Overwrite Delete Edit Undo")
  281.       (setq insovr (getkword (strcat "\nAdd/Insert/Overwrite/Delete/Edit/Undo[Insert]: ")))
  282.       (if (null insovr) (setq insovr "Insert"))
  283.     ))
  284.     (if (and(/= insovr "Delete")(/= insovr "Undo")(/= insovr "Edit")) (progn
  285.       (princ "\nSpecial Titles:\n ~-- = Horizontal line in PopUp, Blank title = Command used for title")
  286.       (setq _ttl (getstring t "\nEnter Menu Title: "))
  287.       (initget 0 "AutoLisp Insert Command Learn")
  288.       (setq _lstyp _typ
  289.         _typ (getkword(strcat "\nAutoLisp/Insert block/Command/Learn[" _lstyp "]: ")))
  290.       (if (null _typ) (setq _typ _lstyp))
  291.       (cond
  292.     ((= _typ "Insert")   (doinsert))
  293.     ((= _typ "AutoLisp") (dolisp))
  294.     ((= _typ "Learn")    (learn))
  295.     (t             (docommand))
  296.       )
  297.     ))
  298.     (if(/= insovr "Undo") (progn
  299.       (writedat)
  300.       (if (= _typ "Learn") (command "" ""))     ;end any pending prompts
  301.       (command "SHELL" "CMENU")
  302.     ) ;else
  303.     (progn
  304.       (setq bakfile (findfile (strcat(getvar "MENUNAME")".cmu")))
  305.       (if (not bakfile) (princ "\nNo backup file found")
  306.     (command "SH" (strcat "copy " bakfile " "
  307.       (findfile (strcat(getvar "MENUNAME")".mnu"))))
  308.       )
  309.     ))
  310.     (setvar "CMDECHO" 1)
  311.     (command "MENU" "")
  312.   ))
  313.   (setvar "CMDECHO" cecho)
  314.   (setq *error* olderr)
  315.   (princ)
  316. )
  317. (princ "\nCMenu loaded - Enter \"CMENU\" to run") (princ)
  318.  
  319.